home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
090
/
byte0487.arc
/
TELLO.ARC
/
LOOP.LSP
< prev
next >
Wrap
Text File
|
1980-01-01
|
10KB
|
269 lines
; the LOOP Macro
(in-package 'SYS)
(defmacro loop (&body body)
(if (symbolp (first body)) (loop-translate body)
(let ((tag (gensym)))
`(block nil (tagbody ,tag ,@body (go ,tag))))))
(defmacro l (&body body) (pprint (loop-translate body)) nil)
(defvar *loop-collect-keywords* '("APPEND" "APPENDING" "COLLECT" "COLLECTING"
"NCONC" "NCONCING"))
(defvar *loop-keywords* '("APPEND" "APPENDING" "AS" "COLLECT" "COLLECTING"
"DO" "DOING" "FINALLY" "FOR" "IF" "INITIALLY"
"NAMED" "NCONC" "NCONCING" "UNLESS" "UNTIL"
"WHEN" "WHILE" "WITH"))
(defun loop-keyword? (object)
(and (symbolp object)
(member (string object) *loop-keywords* :test #'string-equal)))
(defmacro loop-finish () `(go loop-exit-tag))
(defun add-loop-bindings (bindings variable value)
(setf (first bindings)
(nconc (first bindings)
(cond ((not (listp variable))
(list (list variable value)))
((relatively-atomic value)
(generate-loop-destructuring variable value))
(t (let ((temp (gensym)))
(add-loop-bindings (rest bindings) temp value)
(generate-loop-destructuring variable temp)))))))
(defun relatively-atomic (form)
(or (symbolp form)
(and (member (first form) '(car cdr caar cadr cdar cddr caaar caadr
cadar caddr cdaar cdadr cddar cdddr))
(relatively-atomic (second form))
(null (cddr form)))))
(defun generate-loop-destructuring (variables values)
(cond ((null variables) ())
((atom variables) (list (list variables values)))
(t (nconc (generate-loop-destructuring
(car variables) (if (null values) nil `(car ,values)))
(generate-loop-destructuring
(cdr variables) (if (null values) nil `(cdr ,values)))))))
(defun add-for-bindings (bindings forms variable value)
(nconc forms
(cond ((not (listp variable)) `((setf ,variable ,value)))
((relatively-atomic value)
(list (generate-for-destructuring variable value)))
(t (let ((temp (gensym)))
(add-loop-bindings bindings temp nil)
(list `(setf ,temp ,value)
(generate-for-destructuring variable temp)))))))
(defun generate-for-destructuring (variable value)
(let ((bindings (generate-loop-destructuring variable value)))
(if (= (length bindings) 1) (cons 'setf (first bindings))
(cons 'psetf (apply #'nconc bindings)))))
(eval-when (eval compile)
(defmacro lppop (x)
`(if (null ,x) (error "LOOP expression terminates unexpectedly.") (pop ,x))))
(defun loop-collect-form (key symbol expression)
(setf key (aref key 0))
(cond ((char-equal key #\C) ; COLLECT
`(nconc ,symbol (list ,expression)))
((char-equal key #\A) ; APPEND
`(append ,symbol ,expression))
(t ; NCONC
`(nconc ,symbol ,expression))))
(defun loop-for-translate (bindings preset-forms reset-forms body for?)
(let ((key (lppop body)) (temp nil) (temp2 nil) (var nil))
(tagbody
next (unless (symbolp key) (go set))
(when (loop-keyword? key) (go exit))
(when (string-equal (string key) "AND")
(setf key (lppop body))
(setf temp (string key))
(if (string-equal temp "FOR") (setf for? 't)
(if (string-equal temp "AS") (setf for? nil)))
(go next))
set (setf var key)
(setf key (lppop body))
(unless (symbolp key)
(add-loop-bindings bindings var nil) (go next))
(setf temp (string key))
(when (string-equal temp "AND")
(add-loop-bindings bindings var nil) (go next))
(when (loop-keyword? temp)
(add-loop-bindings bindings var nil) (go exit))
(cond ((string-equal temp "=") ;; "FOR/AS X ="
(setf key (lppop body))
(add-loop-bindings bindings var key)
(unless for? ;; "AS X ="
(setf reset-forms
(add-for-bindings bindings reset-forms var key))
(setf key (lppop body)) (go next))
(setf key (lppop body))
(unless (and (symbolp key)
(string-equal (string key) "THEN"))
(go next)) ;; "FOR X = Y THEN"
(setf key (lppop body))
(setf reset-forms
(add-for-bindings bindings reset-forms var key))
(setf key (lppop body))
(go next))
((member temp '("FROM" "DOWNFROM" "UPFROM")
:test #'string-equal)
(unless for? (error "Bad LOOP phrase: AS ~S ~A" var temp))
(let ((by (cond ((string-equal temp "UPFROM") 1)
((string-equal temp "DOWNFROM") -1)
(t nil))))
(setf key (lppop body))
(add-loop-bindings bindings var key)
(setf key (lppop body))
(unless (symbolp key)
(setf reset-forms
(add-for-bindings bindings reset-forms var
`(+ ,var ,(or by 1))))
(go next))
(setf temp2 (string key))
(setf key (lppop body))
(when (string-equal temp2 "BY")
(when by (error "Ill-formed LOOP FOR: ~S ~A BY ..."
var temp))
(setf reset-forms
(add-for-bindings bindings reset-forms var
`(+ ,var ,key)))
(go next))
(unless (member temp2 '("TO" "DOWNTO" "UPTO"
"BELOW" "ABOVE")
:test #'string-equal)
(setf reset-forms
(add-for-bindings bindings reset-forms var
`(+ ,var ,(or by 1))))
(go next))
(BREAK)))
((string-equal temp "IN")
(setf key (lppop body))
(setf temp (gensym))
(add-loop-bindings bindings temp key)
(setf preset-forms
(nconc preset-forms
`((if (null ,temp) (loop-finish)))))
(setf preset-forms
(add-for-bindings bindings preset-forms var `(car ,temp)))
(setf key (lppop body))
(cond ((and (symbolp key) (string-equal (string key) "BY"))
(setf key (lppop body))
(setf reset-forms
(add-for-bindings bindings reset-forms temp
`(funcall ,key ,temp)))
(setf key (lppop body)))
(t (setf reset-forms
(add-for-bindings bindings reset-forms temp
`(cdr ,temp)))))
(go next))
(t (error "FOR/AS keyword expected in LOOP expression: ~S"
key)))
exit)
(values preset-forms reset-forms body key)))
(defun loop-translate (body)
(do ((name nil) ; Loop name.
(bindings ()) ; LET bindings to be made.
(forms ()) ; DO forms.
(init-forms ()) ; Loop initialization forms.
(exit-forms ()) ; Loop finish forms.
(preset-forms ()) ; Loop prepass var reset forms.
(reset-forms ()) ; Loop pass var reset forms.
(key (lppop body)) ; Next keyword to process.
(temp nil))
((null body)
(do ((answer `(tagbody ,@init-forms loop-enter-tag
,@preset-forms ,@forms ,@reset-forms
(go loop-enter-tag)
loop-exit-tag ,@exit-forms)
(let ((binding (pop bindings)))
(if (null binding) answer
`(let ,binding ,answer)))))
((null bindings) `(block ,name ,answer))))
(if (not (symbolp key))
(error "Random form where LOOP keyword expected: ~S" key))
(setf key (string key))
(cond ((string-equal key "NAMED")
(if name (error "LOOP body contains two NAMED keys."))
(setf name (lppop body))
(unless (symbolp name) (error "Bad LOOP name: ~S" name))
(setf key (lppop body)))
((string-equal key "INITIALLY")
(loop (setf key (lppop body))
(if (loop-keyword? key) (return nil))
(setf init-forms (nconc init-forms (list key)))
(unless body (return nil))))
((string-equal key "FINALLY")
(loop (setf key (pop body))
(if (loop-keyword? key) (return nil))
(when (and (symbolp key)
(string-equal (string key) "RETURN"))
(setf exit-forms
(nconc exit-forms `((return ,(lppop body)))))
(setf key (lppop body))
(return nil))
(setf exit-forms (nconc exit-forms (list key)))
(unless body (return nil))))
((string-equal key "WHILE")
(setf temp (lppop body))
(setf key (lppop body))
(setf forms (nconc forms `((unless ,temp (loop-finish))))))
((string-equal key "UNTIL")
(setf temp (lppop body))
(setf key (lppop body))
(setf forms (nconc forms `((when ,temp (loop-finish))))))
((string-equal key "WITH")
(when forms (error "WITH before executable in LOOP BODY."))
(setf bindings (list* () () bindings))
(setf key (lppop body))
(tagbody
next (unless (symbolp key) (go set))
(when (loop-keyword? key) (go exit))
(when (string-equal (string key) "AND")
(setf key (lppop body)) (go next))
set (setf temp key)
(setf key (lppop body))
(cond ((and (symbolp key) (string-equal (string key) "="))
(setf key (lppop body))
(add-loop-bindings bindings temp key)
(setf key (lppop body)))
(t (add-loop-bindings bindings temp nil)))
(go next)
exit))
((or (setf temp (string-equal key "FOR")) (string-equal key "AS"))
(setf bindings (list* () () bindings))
(multiple-value-setq (preset-forms reset-forms body key)
(loop-for-translate bindings preset-forms reset-forms body temp)))
((or (string-equal key "DO") (string-equal key "DOING"))
(loop (setf key (pop body))
(if (loop-keyword? key) (return nil))
(setf forms (nconc forms (list key)))
(unless body (return nil))))
((member key *loop-collect-keywords* :test #'string-equal)
(setf temp key)
(setf bindings (list* () () bindings))
(let ((exp (lppop body)) (symbol (gensym)))
(setf key (pop body))
(when (and key (symbolp key)
(member (string key) '("IN" "INTO")
:test #'string-equal))
(setf symbol (lppop body))
(setf key (pop body)))
(add-loop-bindings bindings symbol nil)
(setf forms
(nconc forms
`((setf ,symbol
,(loop-collect-form temp symbol exp)))))
(setf exit-forms
(nconc exit-forms (list (list 'return symbol))))))
)))